home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / LISP / XLISP / XLISP21S / sources / c / amigastu next >
Text File  |  1992-04-25  |  8KB  |  443 lines
  1. /* amigastuff.c
  2.    Amiga specific routines for XLisp
  3.    originally on Fred Fish #181
  4.    modified for Tom Almy's 2.1c by Hume Smith 1991 Dec 31
  5.    Lattice C 5.04
  6. */
  7.  
  8. #include "xlisp.h"
  9. extern int onbreak(int (*)(void));
  10.  
  11. #ifndef MANX
  12. #define agetc getc   /* Not sure if this will work in all cases (fnf) */
  13. #define aputc putc   /* Not sure if this will work in all cases (fnf) */
  14. #endif
  15.  
  16. #define LBSIZE 200
  17.  
  18. /* external routines */
  19. extern double ran();
  20.  
  21. /* external variables */
  22. extern LVAL s_unbound,true;
  23. extern int prompt;
  24. extern int errno;
  25.  
  26. /* line buffer variables */
  27. static char lbuf[LBSIZE];
  28. static int lpos[LBSIZE];
  29. static int lindex;
  30. static int lcount;
  31. int lposition; /* export to xlprin.c */
  32.  
  33. #define NEW 1006
  34. static long xlispwindow;
  35. extern FILE *tfp;
  36. static void xputc(int),xflush(void);
  37. #ifdef TIMES
  38. static unsigned long basetime;
  39. unsigned long real_tick_count();
  40. #endif
  41.  
  42. /* null function for break handler HCLS */
  43. int breakhandler(void){return 0;}
  44.  
  45. /* osinit - initialize */
  46. void osinit(banner)
  47. char *banner;
  48. {
  49.     onbreak(breakhandler); /* system will ignore ctrl-C ctrl-D HCLS */
  50.     xlispwindow = Open("RAW:0/12/640/188/XLisp", NEW);
  51.     while(*banner) xputc(*banner++);
  52.     xputc('\n');
  53.     lposition = 0;
  54.     lindex = lcount = 0;
  55. #ifdef TIMES
  56.     basetime=real_tick_count();
  57. #endif
  58. }
  59.  
  60. void osfinish ()
  61. {
  62.     Close (xlispwindow);
  63. }
  64.  
  65. /* osrand - return a random number between 0 and n-1 */
  66. int osrand(n)
  67.   int n;
  68. {
  69.     n = (int)(ran() * (double)n);
  70.     return (n < 0 ? -n : n);
  71. }
  72.  
  73. /* oscheck - check for control characters during execution */
  74. void oscheck()
  75. {
  76.     switch (xcheck()) {
  77.  
  78.     case '\002': /* ctrl-b */
  79.     osflush();
  80.     xlbreak("BREAK",s_unbound);
  81.     break;
  82.  
  83.     case '\004': /* ctrl-d */
  84.     osflush();
  85.     xltoplevel();
  86.     break;
  87.     }
  88. }
  89.  
  90. /* osflush - flush the input line buffer */
  91. void osflush()
  92. {
  93.     lindex = lcount = 0;
  94. }
  95.  
  96. /* xgetc - get a character from the terminal without echo */
  97. static int xgetc()
  98. {
  99.     char ch;
  100.  
  101.     Read(xlispwindow, &ch, 1);
  102.     return ch & 0xff;
  103. }
  104.     
  105. /* xputc - put a character to the terminal */
  106. static void xputc(ch)
  107.   int ch;
  108. {
  109.     char chout;
  110.  
  111.     chout = ch;
  112.     Write (xlispwindow, &chout, 1L);
  113. }
  114.  
  115. /* xcheck - check for a character */
  116. static int xcheck()
  117. {
  118.     if (WaitForChar (xlispwindow, 0L) == 0L)
  119.     return (0);
  120.     return (xgetc() & 0xFF);
  121. }
  122.  
  123. double ran ()   /* Just punt for now, not in Manx C; FIXME!!*/
  124. {
  125.    static long seed = 654321;
  126.    long lval;
  127.    double dval;
  128.  
  129.    seed *= ((8 * (123456) - 3));
  130.    lval = seed & 0xFFFF;
  131.    dval = ((double) lval) / ((double) (0x10000));
  132.    return (dval);
  133. }
  134.  
  135. /* ADDED FOR V2.0 */
  136.  
  137. /* osclose - close a file */
  138. int osclose(fp)
  139.   FILE *fp;
  140. {
  141.     return (fclose(fp));
  142. }
  143.  
  144. /* ostputc - put a character to the terminal */
  145. void ostputc(ch)
  146.   int ch;
  147. {
  148.     /* check for control characters */
  149.     oscheck();
  150.  
  151.     /* output the character */
  152.     if (ch == '\n') {
  153.    xputc('\r'); xputc('\n');
  154.    lposition = 0;
  155.     }
  156.     else {
  157.    xputc(ch);
  158.    lposition++;
  159.    }
  160.  
  161.    /* output the character to the transcript file */
  162.    if (tfp)
  163.    osaputc(ch,tfp);
  164. }
  165.  
  166. /* ostgetc - get a character from the terminal */
  167. int ostgetc()
  168. {
  169.     int ch;
  170.  
  171.     /* check for a buffered character */
  172.     if(lcount--)
  173.     return (int)lbuf[lindex++];
  174.  
  175.     /* get an input line */
  176.     for(lcount = 0; ; )
  177.     switch(ch = xgetc()){
  178.     case 3: /* ctrl-c */
  179.         xflush();
  180.         xltoplevel();
  181.  
  182.     case 7: /* ctrl-g */
  183.         xflush();
  184.         xlcleanup();
  185.  
  186.     case 16: /* ctrl-p */
  187.         xflush();
  188.         xlcontinue();
  189.  
  190.     case 26: /* ctrl-z */
  191.         xflush();
  192.         return EOF;
  193.  
  194.     case 13: /* return */
  195.         lbuf[lcount++] = '\n';
  196.         xputc('\r');
  197.         xputc('\n');
  198.         lposition = 0;
  199.         if(tfp)
  200.         for(lindex = 0; lindex < lcount; ++lindex)
  201.             osaputc(lbuf[lindex], tfp);
  202.         lindex = 0;
  203.         lcount--;
  204.         return (int)lbuf[lindex++];
  205.  
  206.     case 8:
  207.     case 127:
  208.         if(lcount){
  209.         lcount--;
  210.         while(lposition > lpos[lcount]){
  211.             xputc('\010');
  212.             xputc(' ');
  213.             xputc('\010');
  214.             lposition--;
  215.         }
  216.         }
  217.         break;
  218.  
  219.     default:
  220.         if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
  221.         lbuf[lcount] = ch;
  222.         lpos[lcount] = lposition;
  223.         if (ch == '\t')
  224.             do {
  225.             xputc(' ');
  226.             } while(++lposition & 7);
  227.         else {
  228.             xputc(ch);
  229.             lposition++;
  230.         }
  231.         lcount++;
  232.        }
  233.     }
  234. }
  235.  
  236. /* xflush - flush the input line buffer */
  237. static void xflush()
  238. {
  239.     ostputc('\n');
  240.     osflush();
  241. }
  242.  
  243. /* osaopen - open an ascii file */
  244. FILE *osaopen(name,mode)
  245.   char *name,*mode;
  246. {
  247.     return (fopen(name,mode));
  248. }
  249.  
  250. /* xoserror - print an error message */
  251. void xoserror(msg)
  252.   char *msg;
  253. {
  254.     printf("error: %s\n",msg);
  255. }
  256.  
  257. /* xsystem - the built-in function 'system' */
  258. LVAL xsystem()
  259. {
  260.     char *str;
  261.     int result;
  262.  
  263.     /* get the command string */
  264.     str = getstring(xlgastring());
  265.     xllastarg();
  266.     result = Execute(str,0L,xlispwindow);
  267.     return (cvfixnum((FIXTYPE)result));
  268. }
  269.  
  270. /* osagetc - get a character from an ascii file */
  271. int osagetc(fp)
  272.   FILE *fp;
  273. {
  274.     return (getc(fp));
  275. }
  276.  
  277. /* osaputc - put a character to an ascii file */
  278. int osaputc(ch,fp)
  279.   int ch; FILE *fp;
  280. {
  281.     return (putc(ch,fp));
  282. }
  283.  
  284. /* ossymbols - lookup important symbols */
  285. void ossymbols()
  286. {
  287. }
  288.  
  289. #ifdef PATHNAMES
  290.  
  291. #define BSIZE (252)
  292.  
  293. /* the Lattice 5.04 libraries have a bug in this funvtion */
  294.  
  295. char *getenv(char *x){
  296.    FILE *f;
  297.    static char val[BSIZE+4]="env:";
  298.    char *r=val+4;
  299.  
  300.    strcpy(r,x);
  301.  
  302.   if(f=fopen(val,"r")){
  303.       if(r==fgets(r,BSIZE,f)){
  304.          int n=strlen(r);
  305.          if(n<BSIZE){
  306.             if(n && r[n-1]=='\n'){
  307.                r[--n]=0; /* trim off any trailing newline */
  308.             }
  309.          }
  310.          else{
  311.             /* line too long for buffer */
  312.             r=0;
  313.          }
  314.       }
  315.       else{
  316.          r=0;
  317.       }
  318.       fclose(f);
  319.    }
  320.    else{
  321.       r=0;
  322.    }
  323.  
  324.    return r;
  325. }
  326.  
  327. #undef BSIZE
  328.  
  329. /* ospopen - open using a search path */
  330. FILE *ospopen(name, ascii)
  331. char *name;
  332. int ascii;
  333. {
  334.     FILE *fp;
  335.     char *paths = getenv(PATHNAMES);
  336.     char *newnamep, ch;
  337.     char newname[256];
  338.  
  339.     /* do no searching if path is explicit */
  340.     if (strchr(name,'/') || !paths)
  341.     return fopen(name, "r");
  342.  
  343.     do {
  344.     if (!*paths)
  345.         /* no more paths, check current directory */
  346.         return fopen(name, "r");
  347.  
  348.     newnamep = newname;
  349.     while ((ch = *paths++) && ch != ';' && ch != ' ')
  350.         *newnamep++ = ch;
  351.  
  352.     if (ch == '\0') paths--;
  353.  
  354.     if (':' != (ch = *(newnamep-1)) && '/' != ch)
  355.         *newnamep++ = '/';  /* final path separator needed */
  356.  
  357.     strcpy(newnamep, name);
  358.     fp = fopen(newname, "r");
  359.     } while (!fp);   /* not yet found */
  360.  
  361.     return fp;
  362. }
  363. #endif
  364.  
  365. #ifdef TIMES
  366. /* the Amiga's clock has microsecond resolution;
  367.    that's too much to be useful here, so we'll
  368.    reduce it arbitrarily to seconds */
  369.  
  370. unsigned long ticks_per_second() { return 1ul; }
  371.  
  372. unsigned long real_tick_count()
  373. {
  374.   unsigned int i[2];
  375.  
  376.   timer(i);
  377.   return i[0];
  378. }
  379.  
  380. unsigned long run_tick_count()
  381. {
  382.   return real_tick_count()-basetime;
  383. }
  384.  
  385. LVAL xtime()
  386. {
  387.   LVAL expr, result;
  388.   unsigned long tm, rtm;
  389.   double dtm, rdtm;
  390.  
  391. /* get the expression to evaluate */
  392.   expr = xlgetarg();
  393.   xllastarg();
  394.  
  395.   tm = run_tick_count();
  396.   rtm = real_tick_count();
  397.   result = xleval(expr);
  398.   tm = run_tick_count() - tm;
  399.   rtm = real_tick_count() - rtm;
  400.   dtm = (tm > 0) ? tm : -tm;
  401.   rdtm = (rtm > 0) ? rtm : -rtm;
  402.   sprintf(buf, "CPU %.2f sec., Real %.2f sec.\n", dtm / ticks_per_second(),
  403.                         rdtm / ticks_per_second());
  404.   trcputstr(buf);
  405.   return(result);
  406. }
  407.  
  408. LVAL xruntime() {
  409.     xllastarg();
  410.     return(cvfixnum((FIXTYPE) run_tick_count()));
  411. }
  412.  
  413. LVAL xrealtime() {
  414.     xllastarg();
  415.     return(cvfixnum((FIXTYPE) real_tick_count()));
  416. }
  417. #endif
  418.  
  419. /* from TAA's unixstuff.c */
  420.  
  421. /* rename argument file as backup, return success name */
  422. int renamebackup(filename)
  423.   char *filename;
  424. {
  425.     char *bufp, ch=0;
  426.  
  427.     /* make a copy with a .bak extension */
  428.     strcpy(buf, filename);
  429.     bufp = &buf[strlen(buf)];
  430.     while (bufp > buf && (ch = *--bufp) != '.' && ch != '/')
  431.     ;
  432.     if (ch == '.')
  433.     strcpy(bufp, ".bak");
  434.     else
  435.     strcat(buf, ".bak");
  436.  
  437.     /* delete previous .bak file */
  438.     remove(buf);
  439.  
  440.     /* rename current file, return 0 on failure */
  441.     return !rename(filename, buf);
  442. }
  443.